home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / apps / circuits / spice2g6.z / spice2g6 / spice / Fortran / card.f < prev    next >
Encoding:
Text File  |  1989-02-03  |  8.7 KB  |  317 lines
  1.       subroutine card
  2.       implicit double precision (a-h,o-z)
  3. c
  4. c     this routine scans the input lines, storing each field into the
  5. c tables ifield, idelim, icolum, and icode.  with the exception of the
  6. c '.end' line, card always reads the next line to check for a possible
  7. c continuation before it exits.
  8. c
  9. c spice version 2g.6  sccsid=tabinf 3/15/83
  10.       common /tabinf/ ielmnt,isbckt,nsbckt,iunsat,nunsat,itemps,numtem,
  11.      1   isens,nsens,ifour,nfour,ifield,icode,idelim,icolum,insize,
  12.      2   junode,lsbkpt,numbkp,iorder,jmnode,iur,iuc,ilc,ilr,numoff,isr,
  13.      3   nmoffc,iseq,iseq1,neqn,nodevs,ndiag,iswap,iequa,macins,lvnim1,
  14.      4   lx0,lvn,lynl,lyu,lyl,lx1,lx2,lx3,lx4,lx5,lx6,lx7,ld0,ld1,ltd,
  15.      5   imynl,imvn,lcvn,nsnod,nsmat,nsval,icnod,icmat,icval,
  16.      6   loutpt,lpol,lzer,irswpf,irswpr,icswpf,icswpr,irpt,jcpt,
  17.      7   irowno,jcolno,nttbr,nttar,lvntmp
  18. c spice version 2g.6  sccsid=status 3/15/83
  19.       common /status/ omega,time,delta,delold(7),ag(7),vt,xni,egfet,
  20.      1   xmu,sfactr,mode,modedc,icalc,initf,method,iord,maxord,noncon,
  21.      2   iterno,itemno,nosolv,modac,ipiv,ivmflg,ipostp,iscrch,iofile
  22. c spice version 2g.6  sccsid=miscel 3/15/83
  23.       common /miscel/ atime,aprog(3),adate,atitle(10),defl,defw,defad,
  24.      1  defas,rstats(50),iwidth,lwidth,nopage
  25. c spice version 2g.6  sccsid=line 3/15/83
  26.       common /line/ achar,afield(15),oldlin(15),kntrc,kntlim
  27. c spice version 2g.6  sccsid=flags 3/15/83
  28.       common /flags/ iprnta,iprntl,iprntm,iprntn,iprnto,limtim,limpts,
  29.      1   lvlcod,lvltim,itl1,itl2,itl3,itl4,itl5,itl6,igoof,nogo,keof
  30. c spice version 2g.6  sccsid=knstnt 3/15/83
  31.       common /knstnt/ twopi,xlog2,xlog10,root2,rad,boltz,charge,ctok,
  32.      1   gmin,reltol,abstol,vntol,trtol,chgtol,eps0,epssil,epsox,
  33.      2   pivtol,pivrel
  34. c spice version 2g.6  sccsid=blank 3/15/83
  35.       common /blank/ value(200000)
  36.       integer nodplc(64)
  37.       complex cvalue(32)
  38.       equivalence (value(1),nodplc(1),cvalue(1))
  39. c
  40.       dimension adigit(10)
  41.       data adigit / 1h0,1h1,1h2,1h3,1h4,1h5,1h6,1h7,1h8,1h9 /
  42.       data ablnk,aper,aplus,aminus,astk / 1h , 1h., 1h+, 1h-, 1h* /
  43.       data bg,ak,au,an,ap,ae,am,af,at /1hg,1hk,1hu,1hn,1hp,1he,1hm,
  44.      1  1hf,1ht/
  45.       data ai / 1hi /
  46.       data alprn, arprn, aequal / 1h(, 1h), 1h= /
  47.       data aend / 4h.end /
  48. c
  49. c      note:  the value of the function *nxtchr* (used extensively in
  50. c this routine) is as follows:
  51. c
  52. c                    <0:  end-of-line
  53. c                    =0:  delimiter found
  54. c                    >0:  non-delimiter found
  55. c
  56.       numfld=0
  57.       nofld=10
  58.       go to 20
  59. c
  60. c  read next card
  61. c
  62.    10 nofld=10
  63.       call getlin
  64.       if (keof.eq.0) go to 20
  65. c...  error:  unexpected end-of-file condition on input
  66.    15 keof=1
  67.       nofld=1
  68.       numfld=0
  69.       igoof=1
  70.       write (iofile,16)
  71.    16 format('0*error*:  .end card missing'/)
  72.       go to 1000
  73. c
  74. c  eliminate trailing blanks rapidly
  75. c
  76.    20 if (afield(nofld).ne.ablnk) go to 40
  77.       if (nofld.eq.1) go to 30
  78.       nofld=nofld-1
  79.       go to 20
  80. c...  write blank card
  81.    30 write (iofile,31)
  82.    31 format(1x)
  83.       go to 10
  84. c...  copy the card to output listing
  85.    40 write (iofile,41) (afield(i),i=1,nofld)
  86.    41 format(1x,10a8)
  87. c
  88. c  initialization for new card
  89. c
  90.    45 kntrc=0
  91.       kntlim=min0(8*nofld,iwidth)
  92. c
  93. c  fetch first non-delimiter (see routine *nxtchr* for list)
  94. c
  95.    50 if (nxtchr(0)) 600,50,60
  96. c...  check for comment (leading asterisk)
  97.    60 if (achar.eq.astk) go to 10
  98.       go to 100
  99. c
  100. c  fetch next character
  101. c
  102.    70 if (nxtchr(0)) 600,80,100
  103. c
  104. c  two consecutive delimiters imply numeric zero unless the delimiter
  105. c  is a blank or parenthesis.
  106. c
  107.    80 if (achar.eq.ablnk) go to 70
  108.       if (achar.eq.alprn) go to 70
  109.       if (achar.eq.arprn) go to 70
  110.       if (achar.eq.aequal) go to 70
  111. c...  check for sufficient space in storage arrays
  112.       if (numfld.lt.insize-1) go to 90
  113.       call extmem(ifield,50)
  114.       call extmem(icode,50)
  115.       call extmem(idelim,50)
  116.       call extmem(icolum,50)
  117.       insize=insize+50
  118.    90 numfld=numfld+1
  119.       value(ifield+numfld)=0.0d0
  120.       nodplc(icode+numfld)=0
  121.       value(idelim+numfld)=achar
  122.       nodplc(icolum+numfld)=kntrc
  123.       go to 70
  124. c
  125. c  check for sufficient space in storage arrays
  126. c
  127.   100 if (numfld.lt.insize-1) go to 110
  128.       call extmem(ifield,50)
  129.       call extmem(icode,50)
  130.       call extmem(idelim,50)
  131.       call extmem(icolum,50)
  132.       insize=insize+50
  133. c
  134. c  begin scan of next field
  135. c
  136. c...  initialization
  137.   110 jdelim=0
  138.       xsign=1.0d0
  139.       xmant=0.0d0
  140.       idec=0
  141.       iexp=0
  142. c...  check for leading plus or minus sign
  143.       if (achar.eq.aplus) go to 210
  144.       if (achar.eq.aminus) go to 200
  145. c...  finish initialization
  146.       anam=ablnk
  147.       kchr=1
  148. c...  an isolated period indicates that a continuation card follows
  149.       if (achar.ne.aper) go to 120
  150. c...  alter initialization slightly if leading period found
  151.       idec=1
  152.       iexp=-1
  153.       anam=aper
  154.       kchr=2
  155. c...  now take a look at the next character
  156.       if (nxtchr(0)) 10,10,120
  157. c
  158. c  test for number (any digit)
  159. c
  160.   120 do 130 i=1,10
  161.       if (achar.ne.adigit(i)) go to 130
  162.       xmant=dble(i-1)
  163.       go to 210
  164.   130 continue
  165. c
  166. c  assemble name
  167. c
  168.       numfld=numfld+1
  169.       call move(anam,kchr,achar,1,1)
  170.       kchr=kchr+1
  171.       do 150 i=kchr,8
  172.       if (nxtchr(0)) 160,160,140
  173.   140 call move(anam,i,achar,1,1)
  174.   150 continue
  175.       go to 170
  176.   160 jdelim=1
  177.   170 value(ifield+numfld)=anam
  178.       nodplc(icode+numfld)=1
  179.       nodplc(icolum+numfld)=kntrc
  180. c...  no '+' format continuation possible for .end card
  181.       if (numfld.ge.2) go to 400
  182.       if (anam.ne.aend) go to 400
  183.       nodplc(icode+numfld+1)=-1
  184.       go to 1000
  185. c
  186. c  process number
  187. c
  188. c...  take note of leading minus sign
  189.   200 xsign=-1.0d0
  190. c...  take a look at the next character
  191.   210 if (nxtchr(0)) 335,335,220
  192. c...  test for digit
  193.   220 do 230 i=1,10
  194.       if (achar.ne.adigit(i)) go to 230
  195.       xmant=xmant*10.0d0+dble(i-1)
  196.       if (idec.eq.0) go to 210
  197.       iexp=iexp-1
  198.       go to 210
  199.   230 continue
  200. c
  201. c  check for decimal point
  202. c
  203.       if (achar.ne.aper) go to 240
  204. c...  make certain that this is the first one found
  205.       if (idec.ne.0) go to 500
  206.       idec=1
  207.       go to 210
  208. c
  209. c  test for exponent
  210. c
  211.   240 if (achar.ne.ae) go to 300
  212.       if (nxtchr(0)) 335,335,250
  213.   250 itemp=0
  214.       isign=1
  215. c...  check for possible leading sign on exponent
  216.       if (achar.eq.aplus) go to 260
  217.       if (achar.ne.aminus) go to 270
  218.       isign=-1
  219.   260 if (nxtchr(0)) 285,285,270
  220. c...  test for digit
  221.   270 do 280 i=1,10
  222.       if (achar.ne.adigit(i)) go to 280
  223.       itemp=itemp*10+i-1
  224.       go to 260
  225.   280 continue
  226.       go to 290
  227.   285 jdelim=1
  228. c...  correct internal exponent
  229.   290 iexp=iexp+isign*itemp
  230.       go to 340
  231. c
  232. c  test for scale factor
  233. c
  234.   300 if (achar.ne.am) go to 330
  235. c...  special check for *me* (as distinguished from *m*)
  236.       if (nxtchr(0)) 320,320,310
  237.   310 if (achar.ne.ae) go to 315
  238.       iexp=iexp+6
  239.       go to 340
  240.   315 if (achar.ne.ai) go to 325
  241.       xmant=xmant*25.4d-6
  242.       go to 340
  243.   320 jdelim=1
  244.   325 iexp=iexp-3
  245.       go to 340
  246.   330 if (achar.eq.at) iexp=iexp+12
  247.       if (achar.eq.bg) iexp=iexp+9
  248.       if (achar.eq.ak) iexp=iexp+3
  249.       if (achar.eq.au) iexp=iexp-6
  250.       if (achar.eq.an) iexp=iexp-9
  251.       if (achar.eq.ap) iexp=iexp-12
  252.       if (achar.eq.af) iexp=iexp-15
  253.       go to 340
  254.   335 jdelim=1
  255. c
  256. c  assemble the final number
  257. c
  258.   340 if (xmant.eq.0.0d0) go to 350
  259.       if (iexp.eq.0) go to 350
  260.       if (iabs(iexp).ge.201) go to 500
  261.       xmant=xmant*dexp(dble(iexp)*xlog10)
  262.       if (xmant.gt.1.0d+35) go to 500
  263.       if (xmant.lt.1.0d-35) go to 500
  264.   350 numfld=numfld+1
  265.       value(ifield+numfld)=dsign(xmant,xsign)
  266.       nodplc(icode+numfld)=0
  267.       nodplc(icolum+numfld)=kntrc
  268. c
  269. c  skip to non-blank delimiter (if necessary)
  270. c
  271.   400 if (jdelim.eq.0) go to 440
  272.   410 value(idelim+numfld)=achar
  273.       if (achar.ne.ablnk) go to 70
  274.       if (nxtchr(0)) 450,410,420
  275.   420 kntrc=kntrc-1
  276.       go to 70
  277.   440 if (nxtchr(0)) 450,410,440
  278.   450 value(idelim+numfld)=achar
  279.       go to 600
  280. c
  281. c  errors
  282. c
  283.   500 write (iofile,501) kntrc
  284.   501 format('0*error*:  illegal number -- scan stopped at column ',i3/)
  285.       igoof=1
  286.       numfld=numfld+1
  287.       value(ifield+numfld)=0.0d0
  288.       nodplc(icode+numfld)=0
  289.       value(idelim+numfld)=achar
  290.       nodplc(icolum+numfld)=kntrc
  291. c
  292. c  finished
  293. c
  294.   600 nodplc(icode+numfld+1)=-1
  295. c
  296. c  check next line for possible continuation
  297. c
  298.   610 call getlin
  299.       if (keof.eq.1) go to 15
  300.       nofld=10
  301.   620 if (afield(nofld).ne.ablnk) go to 630
  302.       if (nofld.eq.1) go to 650
  303.       nofld=nofld-1
  304.       go to 620
  305.   630 kntrc=0
  306.       kntlim=min0(8*nofld,iwidth)
  307. c...  continuation line has a '+' as first non-delimiter on card
  308.   632 if(nxtchr(0)) 650,632,634
  309.   634 if(achar.ne.aplus) go to 640
  310.       write(iofile,41) (afield(i),i=1,nofld)
  311.       go to 70
  312.   640 if (achar.ne.astk) go to 1000
  313.   650 write (iofile,41) (afield(i),i=1,nofld)
  314.       go to 610
  315.  1000 return
  316.       end
  317.